(* ===================================================================== *)
(** LIST MAP : module integrant, arbres AVL.  
    Interet par rapport a Map : ajouter des elements 'a dans une map 
    dont les valeurs des clés sont des 'a list.
    Rendre la liste vide au lieu de Not_found si a n'est pas dans la table 
    
    Contient egalement les outils de tri topologique générique.
*)
(* ===================================================================== *)

(** <h2> ListMap </h2> *)

open Bplib

(* Inutile de commenter ce module, c'est quasiment le module Map des sources Ocaml (projet Cristal) : il y est deja documenté *)

module type OrderedType =
  sig
    type t
    val compare: t -> t -> int
  end

module type S =
  sig
    type key
    type +'a t
    val empty: 'a t
    val is_empty: 'a t -> bool
    val add: ('a -> 'a -> int) -> key -> 'a -> 'a t -> 'a t
    val find: key -> 'a t -> 'a list
    val remove: key -> 'a t -> 'a t
    val mem:  key -> 'a t -> bool
    val iter: (key -> 'a -> unit) -> 'a t -> unit
    val map: ('a -> 'b) -> 'a t -> 'b t
    val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
  (*   val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b *)
  (*   val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int *)  
  (*   val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool *)
  end

module Make(Ord: OrderedType) : S with type key = Ord.t = struct

    type key = Ord.t

    type 'a t =
        Empty
      | Node of 'a t * key * ('a list) * 'a t * int

    let insert_tri cmp v = 
      let rec aux = function
	| [] -> [v]
	| (t::q) as ll ->
	    let res = cmp v t in
	    if res < 0
	    then v::ll
	    else 
	      if res > 0
	      then t::(aux q)
	      else ll
      in aux
      

    let height = function
        Empty -> 0
      | Node(_,_,_,_,h) -> h

    let create l x d r =
      let hl = height l and hr = height r in
      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))

    let bal l x d r =
      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
      if hl > hr + 2 then begin
        match l with
          Empty -> invalid_arg "Map.bal"
        | Node(ll, lv, ld, lr, _) ->
            if height ll >= height lr then
              create ll lv ld (create lr x d r)
            else begin
              match lr with
                Empty -> invalid_arg "Map.bal"
              | Node(lrl, lrv, lrd, lrr, _)->
                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
            end
      end else if hr > hl + 2 then begin
        match r with
          Empty -> invalid_arg "Map.bal"
        | Node(rl, rv, rd, rr, _) ->
            if height rr >= height rl then
              create (create l x d rl) rv rd rr
            else begin
              match rl with
                Empty -> invalid_arg "Map.bal"
              | Node(rll, rlv, rld, rlr, _) ->
                  create (create l x d rll) rlv rld (create rlr rv rd rr)
            end
      end else
        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))

    let empty = Empty

    let is_empty = function Empty -> true | _ -> false

    let add cmp x data = 
      let rec aux = function
          Empty ->
            Node(Empty, x, [data], Empty, 1)
	| Node(l, v, d, r, h) ->
            let c = Ord.compare x v in
            if c = 0 then
              Node(l, x, insert_tri cmp data d, r, h)
            else if c < 0 then
              bal (aux l) v d r
            else
              bal l v d (aux r)
      in aux

    let rec find x = function
        Empty -> []
          (* raise Not_found *)
      | Node(l, v, d, r, _) ->
          let c = Ord.compare x v in
          if c = 0 then d
          else find x (if c < 0 then l else r)

    let rec mem x = function
        Empty ->
          false
      | Node(l, v, d, r, _) ->
          let c = Ord.compare x v in
          c = 0 || mem x (if c < 0 then l else r)

    let rec min_binding = function
        Empty -> raise Not_found
      | Node(Empty, x, d, r, _) -> (x, d)
      | Node(l, x, d, r, _) -> min_binding l

    let rec remove_min_binding = function
        Empty -> invalid_arg "Map.remove_min_elt"
      | Node(Empty, x, d, r, _) -> r
      | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r

    let merge t1 t2 =
      match (t1, t2) with
        (Empty, t) -> t
      | (t, Empty) -> t
      | (_, _) ->
          let (x, d) = min_binding t2 in
          bal t1 x d (remove_min_binding t2)

    let rec remove x = function
        Empty ->
          Empty
      | Node(l, v, d, r, h) ->
          let c = Ord.compare x v in
          if c = 0 then
            merge l r
          else if c < 0 then
            bal (remove x l) v d r
          else
            bal l v d (remove x r)

    let rec iter f = function
        Empty -> ()
      | Node(l, v, d, r, _) ->
          iter f l; List.iter (fun e -> f v e) d; iter f r

    let rec map f = function
        Empty               -> Empty
      | Node(l, v, d, r, h) -> Node(map f l, v, List.map f d, map f r, h)

    let rec mapi f = function
        Empty               -> Empty
      | Node(l, v, d, r, h) -> Node(mapi f l, v, List.map (fun e -> f v e) d, mapi f r, h)
end


(** <h2> Tri topologique </h2> *)
 
module type TriableElement =
  sig 
    type t
    val equal : t -> t -> bool
    val index : t -> string
    val depends : t -> string list
  end


module TriTopo (Elemt: TriableElement) = 
struct

  type infos_elt = 
      {
	tri_topo_elt : Elemt.t;
	tri_topo_depends : string list
      }

  let tri_topo elt_list =
    (* Creation des environnements *)
    let f_fold (accu_map, accu_list) elt =
      let index = Elemt.index elt and depends = Elemt.depends elt in
      let topo_elt =  { tri_topo_elt = elt; tri_topo_depends = depends } in
      ((StringMap.add index topo_elt accu_map), 
      (index::accu_list))
    in
    let map_dep, rev_list_dep = List.fold_left f_fold (StringMap.empty, []) elt_list in
    let list_dep = List.rev rev_list_dep in
    (* On lance le tri *)
    let not_referenced = Stack.create () in
    let visited = ref StringSet.empty in
    let ordered = Stack.create () in
    let rec visite s infos_elt =
	if StringSet.mem s (!visited) 
	then ()
	else 
	  begin
	    (* se dire visité *)
	    visited := StringSet.add s (!visited);
	    (* visiter les voisins *)
	    (* creer la liste des voisins viables *)
	    let safe_voisins = 
	      let f_fold accu v =
		try
		  let voisin = StringMap.find v map_dep in
		  (v, voisin)::accu
		with 
		| Not_found -> Stack.push (v, s) not_referenced; accu
	      in List.fold_left f_fold [] infos_elt.tri_topo_depends
	    in
	    List.iter (fun (a,b) -> visite a b) safe_voisins;
	    (* se mettre dans le tri *)
	    Stack.push s ordered
	  end
    in
    (* Faire le parcours dans l'ordre donne : stabilite du tri topo *)
    List.iter (fun a -> 
		 let b = 
		   try 
		     StringMap.find a map_dep
		   with
		   | Not_found -> failwith "TRI TOPO failwith error"
		 in
		 visite a b) list_dep;
    (* StringMap.iter visite map_dep; : posait probleme *)
    (* acceder aux listes des index not_referenced, et de l'association ordered, elt *)
    let list_not_referenced = 
      let rec aux accu =
	if Stack.is_empty not_referenced then accu else aux ((Stack.pop not_referenced)::accu)
      in aux []
    in
    let list_assoc =
      let rec aux accu =
	if Stack.is_empty ordered then accu 
	else 
	  let index = Stack.pop ordered in
	  aux ((index, (StringMap.find index map_dep).tri_topo_elt)::accu)
      in aux []
    in (list_assoc, list_not_referenced)
end


(* ===================================================================== *)
(** On va avoir besoin d'une fonction de mapping avec accumulateur :
    non terminal (comme map) *)
(* ===================================================================== *)
let list_fold_map fct =
  let rec aux accu = function
    | [] -> []
    | t::q -> 
	let new_accu, image = fct accu t in
	image::(aux new_accu q)
  in aux 
(* ===================================================================== *)


exception LengthError

(* ===================================================================== *)
(** Vesion Recursive terminale du fold_left2 sur un couple de 2 listes
    de meme longueur : arguments classiques des fcts de type fold *)
(* ===================================================================== *)
let double_fold_left_list f = 
  let rec aux accu = function
    | [], [] -> accu
    | [], o -> raise LengthError
    | o, [] -> raise LengthError
    | t1::q1, t2::q2 -> aux (f accu t1 t2) (q1,q2)
  in aux 
(* ===================================================================== *)



(* TESTS *)
(*
module StringTopo : TriableElement with type t = string * string list =
struct
  type t = string * string list
      
  let equal a b = 
    match a,b with
    | (u, _), (v, _) ->  String.compare u v = 0
    
  let index = function (a, _) -> a
    
  let depends = function (_, a) -> a
end
  
  ;;
module TestTri = TriTopo (StringTopo);;

let t1 = 
  [
    ("f", []);
    ("y", ["b"; "c"; "d"; "b"]);
    ("b", ["c"; "c"]);
    ("e", []);
    ("c", ["d"]);
    ("f", ["b"])
  
  ];;

let a, b = TestTri.tri_topo t1;;
a;;



*)
